home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 22 / CU Amiga Magazine's Super CD-ROM 22 (1998)(EMAP Images)(GB)[!][issue 1998-05].iso / PowerPC / Programming / PPCsiod / sources / environment.c next >
Encoding:
C/C++ Source or Header  |  1993-09-22  |  12.3 KB  |  441 lines
  1. /* Scheme In One Define.
  2.  
  3. The garbage collector, the name and other parts of this program are
  4.  
  5.  *                     COPYRIGHT (c) 1989 BY                              *
  6.  *      PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
  7.  
  8. Conversion  to  full scheme standard, characters, vectors, ports, complex &
  9. rational numbers, and other major enhancments by
  10.  
  11.  *      Scaglione Ermanno, v. Pirinoli 16 IMPERIA P.M. 18100 ITALY        * 
  12.  
  13. Permission  to use, copy, modify, distribute and sell this software and its
  14. documentation  for  any purpose and without fee is hereby granted, provided
  15. that  the  above  copyright  notice appear in all copies and that both that
  16. copyright   notice   and   this  permission  notice  appear  in  supporting
  17. documentation,  and that the name of Paradigm Associates Inc not be used in
  18. advertising or publicity pertaining to distribution of the software without
  19. specific, written prior permission.
  20.  
  21. PARADIGM  DISCLAIMS  ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
  22. ALL  IMPLIED  WARRANTIES  OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
  23. PARADIGM  BE  LIABLE  FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
  24. ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
  25. IN  AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT
  26. OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  27.  
  28. */
  29.  
  30. #include <stdio.h>
  31. #include <string.h>
  32. #include <ctype.h>
  33. #include <setjmp.h>
  34. #include <signal.h>
  35. #include <math.h>
  36.  
  37. #include "siod.h"
  38.  
  39. LISP envcons(LISP bindings,LISP parent)
  40. {long flag;
  41.  LISP e;
  42.  flag = no_interrupt(1);
  43.  NEWCELL(e,tc_environment);
  44.  BINDINGS(e)=bindings;
  45.  PARENT(e)=parent;
  46.  no_interrupt(flag);
  47.  return(e);}
  48.  
  49. LISP extend_env(LISP bindings,LISP env)
  50. {LISP list;
  51.  list=car(bindings);
  52.  if(CONSP(list))
  53.    {for(list=bindings;CONSP(CDR(list));list = CDR(list));
  54.     CDR(list) = BINDINGS(env);
  55.     BINDINGS(env)=bindings;
  56.     return(env);}
  57.  BINDINGS(env)=cons(bindings,BINDINGS(env));
  58.  return(env);}  
  59.  
  60. LISP envlookup(LISP name,LISP env)
  61. {LISP tmp,l;
  62.  if(NULLP(env)) return(NIL);
  63.  for(l=BINDINGS(env);CONSP(l);l=CDR(l))
  64.    {tmp = CAR(l);
  65.     if (EQ(car(tmp),name)) return(tmp);}
  66.  return(envlookup(name,PARENT(env)));}
  67.  
  68. LISP framelookup(LISP name,LISP bindings)
  69. {LISP tmp,l;
  70.  for(l=bindings;CONSP(l);l=CDR(l))
  71.    {tmp = CAR(l);
  72.     if (EQ(car(tmp),name)) return(tmp);}
  73.  return(NIL);}
  74.  
  75. LISP proc_env(LISP proc)
  76. {if(NTYPEP(proc,tc_closure) &&
  77.     NTYPEP(proc,tc_rec) &&
  78.     NTYPEP(proc,tc_fluidclosure))
  79.          err("procedure-environment",proc,ERR_GEN_ARG | ERR_NPRO);
  80.  return(DEFENV(proc));}
  81.  
  82. LISP proc_code(LISP proc)
  83. {if(NTYPEP(proc,tc_closure) && 
  84.     NTYPEP(proc,tc_rec) && 
  85.     NTYPEP(proc,tc_fluidclosure))
  86.          err("procedure-code",proc,ERR_GEN_ARG | ERR_NPRO);
  87.  return(CODE(proc));}
  88.  
  89. LISP environment_bindings(LISP env)
  90. {if(EQ(env,sym_user_environment)) return(NIL);
  91.  else if(NENVP(env)) err("environment-bindings",env,ERR_GEN_ARG | ERR_NENV);
  92.  return(BINDINGS(env));}
  93.  
  94. LISP environment_parent(LISP env)
  95. {if(EQ(env,sym_user_environment)) return(NIL);
  96.  else if(NENVP(env)) err("environment-parent",env,ERR_GEN_ARG | ERR_NENV);
  97.  return(NULLP(PARENT(env))?sym_user_environment:PARENT(env));}
  98.  
  99. LISP envp(LISP env)
  100. {if(ENVP(env)||EQ(env,sym_user_environment))return(truth);
  101.  return(NIL);}
  102.  
  103. LISP syntax_define(LISP args)
  104. {LISP s;
  105.  s = car(args);
  106.  if NCONSP(s) return(args);
  107.  return(syntax_define(
  108.         cons(CAR(s),
  109.     cons(cons(sym_lambda,
  110.          cons(CDR(s),
  111.           cdr(args))),
  112.          NIL))));}
  113.       
  114. LISP leval_define(LISP args,LISP env)
  115. {long flag;
  116.  LISP tmp,var,val;
  117.  if(NULLP(args))err("nothing to define",NIL,ERR_GEN);
  118.  tmp = syntax_define(args);
  119.  var = car(tmp);
  120.  if(TYPEP(VCELL(var),tc_fsubr)||
  121.     TYPEP(VCELL(var),tc_msubr))
  122.    put_st("WARNING: modifing a special form");
  123.  flag = no_interrupt(1);
  124.  if NSYMBOLP(var) 
  125.    err("attempting to define a non symbol value",var,ERR_GEN);
  126.  val = leval(car(cdr(tmp)),env);
  127.  if(NULLP(env))
  128.    VCELL(var) = val;
  129.  else
  130.   {tmp = framelookup(var,BINDINGS(env));
  131.    if NNULLP(tmp) 
  132.      CDR(tmp) = val;
  133.    else
  134.      extend_env(cons(var,val),env);}
  135.  no_interrupt(flag);
  136.  return(var);}
  137.  
  138. LISP laccess(LISP form,LISP env)
  139. {LISP tmp,pair,renv;
  140.  tmp = car(form);
  141.  renv = leval(car(cdr(form)),env);
  142.  if(NSYMBOLP(tmp))
  143.    err("access",tmp,ERR_FIRST | ERR_NSYM);
  144.  if(EQ(renv,sym_user_environment)) 
  145.     renv = NIL;
  146.  else if(NULLP(renv))
  147.     renv = env;
  148.  else if(NENVP(renv))
  149.    err("access",renv,ERR_SECOND | ERR_NENV);
  150.  pair = envlookup(tmp,renv); 
  151.  if(NNULLP(pair))
  152.    return(cdr(pair));
  153.  if(NEQ(VCELL(tmp),unbound_marker))
  154.    return(VCELL(tmp));
  155.  err("symbol not defined in current environment",tmp,ERR_GEN);
  156. }
  157.  
  158. LISP unboundp(LISP form,LISP env)
  159. {LISP tmp,renv,pair;
  160.  tmp = car(form);
  161.  renv = leval(car(cdr(form)),env);
  162.  if(NSYMBOLP(tmp))
  163.    err("unbound?",tmp,ERR_FIRST | ERR_NSYM);
  164.  if(EQ(renv,sym_user_environment)) 
  165.     renv = NIL;
  166.  else if(NULLP(renv))
  167.   renv = env;
  168.  else if(NENVP(renv))
  169.    err("unbound?",renv,ERR_SECOND | ERR_NENV);
  170.  pair = envlookup(tmp,renv);
  171.  if(NULLP(pair) && EQ(VCELL(tmp),unbound_marker))
  172.    return(truth);
  173.  else
  174.    return(NIL);}
  175.  
  176. LISP setvar(LISP var,LISP val,LISP env)
  177. {LISP tmp;
  178.  if (NSYMBOLP(var) && NCONSP(var)) 
  179.    err("set!",var,ERR_FIRST | ERR_NSYM);
  180.  if CONSP(var)
  181.   {if(EQ(CAR(var),cintern("access")))
  182.     {env=leval(car(cdr(CDR(var))),env);
  183.      var=car(CDR(var));}
  184.    else if(EQ(CAR(var),cintern("fluid")))
  185.      return(setfluidvar(car(CDR(var)),val));
  186.    else if(EQ(CAR(var),cintern("vector-ref")))
  187.      return(vectorset(leval(car(CDR(var)),env),
  188.                       leval(car(cdr(CDR(var))),env),val));}
  189.  tmp = envlookup(var,env);
  190.  if NULLP(tmp)
  191.   {if(EQ(VCELL(var),unbound_marker))
  192.      err("simbol not found in current environment",var,ERR_GEN);
  193.    if(TYPEP(VCELL(var),tc_fsubr)||
  194.       TYPEP(VCELL(var),tc_msubr))
  195.       put_st("WARNING: modifing a special form");
  196.    VCELL(var) = val;
  197.    return(var);}
  198.  CDR(tmp)=val;
  199.  return(var);}
  200.  
  201. LISP setv(LISP var,LISP val)
  202. {VCELL(var) = val;
  203.  return(var);}
  204.  
  205. LISP leval_setq(LISP args,LISP env)
  206. {return(setvar(car(args),leval(car(cdr(args)),env),env));}
  207.  
  208. LISP leval_tenv(LISP args,LISP env)
  209. {if(NULLP(env)) 
  210.     return sym_user_environment;
  211.  else return(env);}
  212.  
  213. LISP leval_lambda(LISP args,LISP env)
  214. {LISP body;
  215.  if NULLP(args) err("lambda",args,ERR_FIRST | ERR_NPAI);
  216.  body = cdr(args);
  217.  if NULLP(cdr(body))
  218.    body = car(body);
  219.  else body = cons(sym_progn,body);
  220.  return(closure(env,cons(arglchk(car(args)),body)));}
  221.                          
  222. LISP leval_macro(LISP args,LISP env)
  223. {long flag;
  224.  char *p;
  225.  LISP expander,sym,tmp,mac;
  226.  sym = car(args);
  227.  expander = leval(car(cdr(args)),env);
  228.  if (!(procp(expander))) err("macro",expander,ERR_SECOND | ERR_NPRO);
  229.  if (NSYMBOLP(sym)) 
  230.     err("macro",sym,ERR_FIRST | ERR_NSYM);
  231.  flag = no_interrupt(1);
  232.  mac = symcons(PNAME(sym),expander);
  233.  (*mac).type = tc_macro;
  234.  if(NULLP(env))
  235.    VCELL(sym) = mac;
  236.  else
  237.   {tmp = framelookup(sym,BINDINGS(env));
  238.    if NNULLP(tmp) 
  239.      CDR(tmp) = mac;
  240.    else
  241.      extend_env(cons(sym,mac),env);}
  242.  no_interrupt(flag);
  243.  return(sym);}
  244.  
  245. LISP leval_aut_fr_fi(LISP args,LISP env)
  246. {LISP name,vars,envi,expand;
  247.  name = leval(car(args),env);
  248.  vars = leval(car(cdr(args)),env);
  249.  envi = leval(car(cdr(cdr(args))),env);
  250.  if NSTRINGP(name) err("autoload-from-file",name,ERR_FIRST | ERR_NSTR);
  251.  if NCONSP(vars) err("autoload-from-file",vars,ERR_SECOND | ERR_NPAI);
  252.  if(NULLP(envi))
  253.     {if(NULLP(env))
  254.         envi = cintern("user-global-environment");
  255.      else
  256.         envi=env;}
  257.  else if EQ(envi,sym_user_environment)
  258.     envi = cintern("user-global-environment");
  259.  else if NENVP(envi)
  260.     err("autoload-from-file",envi,ERR_THIRD | ERR_NENV);
  261.  expand = closure(env,
  262.                   cons(cons(cintern("x"),NIL),
  263.                        cons(sym_progn,
  264.                             cons(cons(cintern("load"),
  265.                                       cons(name,cons(envi,NIL))),
  266.                                  cons(cintern("x"),NIL)))));  
  267.  while(CONSP(vars))
  268.   {leval_macro(cons(car(vars),cons(expand,NIL)),env);
  269.    vars=cdr(vars);}
  270.  return(name);}
  271.  
  272. LISP leval_named_lambda(LISP args,LISP env)
  273. {LISP body;
  274.  if NCONSP(car(args)) err("named-lambda",args,ERR_FIRST | ERR_NPAI);
  275.  body = cdr(args);
  276.  if NULLP(cdr(body))
  277.    body = car(body);
  278.   else body = cons(sym_progn,body);
  279.  return(rec_closure(env,cons(arglchk(car(args)),body)));}
  280.  
  281. LISP arglchk(LISP x)
  282. {LISP l;
  283.  if SYMBOLP(x) return(x);
  284.  for(l=x;CONSP(l);l=CDR(l))
  285.    if NSYMBOLP(CAR(l)) 
  286.       err("improper formal argument list",x,ERR_GEN);
  287.  if (NNULLP(l) && NSYMBOLP(l)) 
  288.     err("improper formal argument list",x,ERR_GEN);
  289.  return(x);}
  290.  
  291. void env_test(LISP env)
  292. {LISP l,tmp;
  293.  for(l=env;CONSP(l);l=CDR(l))
  294.    {tmp = CAR(l);
  295.     if (NCONSP(tmp) || NSYMBOLP(car(tmp)) || NCONSP(cdr(tmp))) 
  296.         err("improper binding found in a let-form variable list",tmp,ERR_GEN);}
  297.  if NNULLP(l) err("improper binding found in a let-form variable list",l,ERR_GEN);}
  298.    
  299. LISP leval_let_env(LISP bind,LISP env)
  300. {LISP l,tmp,nbi;
  301.  nbi = NIL;
  302.  for(l=bind;CONSP(l);l=CDR(l))
  303.   {tmp=CAR(l);
  304.    nbi = cons(cons(car(tmp),
  305.               leval(car(cdr(tmp)),env)),nbi);}
  306.  return(nbi);}
  307.    
  308. LISP leval_let(LISP *pform,LISP *penv)
  309. {LISP env,l,bin;
  310.  l = cdr(*pform);
  311.  if NULLP(l) err("let",l,ERR_FIRST | ERR_NPAI);
  312.  bin = car(l);
  313.  env = *penv;
  314.  env_test(bin);
  315.  *penv = envcons(leval_let_env(bin,env),env);
  316.  l = cdr(l);
  317.  if(NNULLP(cdr(l)))
  318.    *pform = cons(sym_progn,l);
  319.  else
  320.    *pform = car(l);
  321.  return(truth);}
  322.  
  323. LISP leval_let_star_env(LISP bind,LISP env)
  324. {LISP l,newenv,tmp,nbis;
  325.  newenv = env;
  326.  for(l=bind;CONSP(l);l=CDR(l))
  327.   {tmp=CAR(l);
  328.    newenv = envcons(NIL,newenv);
  329.    nbis = cons(car(tmp),car(cdr(tmp)));
  330.    CDR(nbis) = leval(CDR(nbis),newenv);
  331.    extend_env(nbis,newenv);}
  332.  return(newenv);}
  333.  
  334. LISP leval_let_star(LISP *pform,LISP *penv)
  335. {LISP env,l,bin;
  336.  l = cdr(*pform);
  337.  if NULLP(l) err("let*",l,ERR_FIRST | ERR_NPAI);
  338.  bin = car(l);
  339.  env = *penv;
  340.  env_test(bin);
  341.  *penv = leval_let_star_env(bin,env);
  342.  l = cdr(l);
  343.  if(NNULLP(cdr(l)))
  344.    *pform = cons(sym_progn,l);
  345.  else
  346.    *pform = car(l);
  347.  return(truth);}
  348.    
  349. LISP leval_letrec_env(LISP bind,LISP env)
  350. {LISP l,newenv,tmp;
  351.  newenv = envcons(NIL,env);
  352.  for(l=bind;CONSP(l);l=CDR(l))
  353.   {tmp=CAR(l);
  354.    extend_env(cons(car(tmp),
  355.               car(cdr(tmp))),newenv);}
  356.  for(l=BINDINGS(newenv);CONSP(l);l=CDR(l))
  357.   {tmp=CAR(l);
  358.    CDR(tmp) = leval(cdr(tmp),newenv);}
  359.  return(newenv);}
  360.  
  361. LISP leval_letrec(LISP *pform,LISP *penv)
  362. {LISP env,l,bin;
  363.  l = cdr(*pform);
  364.  if NULLP(l) err("letrec",l,ERR_FIRST | ERR_NPAI);
  365.  bin = car(l);
  366.  env = *penv;
  367.  env_test(bin);
  368.  *penv = leval_letrec_env(bin,env);
  369.  l = cdr(l);
  370.  if(NNULLP(cdr(l)))
  371.    *pform = cons(sym_progn,l);
  372.  else
  373.    *pform = car(l);
  374.  return(truth);}
  375.  
  376. LISP fluid(LISP form,LISP env)
  377. {LISP tmp,pair;
  378.  tmp = car(form);
  379.  if(NSYMBOLP(tmp))
  380.    err("fluid",tmp,ERR_GEN_ARG | ERR_NSYM);
  381.  pair = envlookup(tmp,sym_fluid_environment); 
  382.  if(NULLP(pair))
  383.    err("symbol not defined in fluid environment",tmp,ERR_GEN);
  384.  return(cdr(pair));}
  385.  
  386. LISP fluid_boundp(LISP form,LISP env)
  387. {LISP tmp,pair;
  388.  tmp = car(form);
  389.  if(NSYMBOLP(tmp))
  390.    err("fluid-bound?",tmp,ERR_GEN_ARG | ERR_NSYM);
  391.  pair = envlookup(tmp,sym_fluid_environment);
  392.  if(NULLP(pair))
  393.    return(NIL);
  394.  else
  395.    return(truth);}
  396.  
  397. LISP setfluidvar(LISP var,LISP val)
  398. {LISP tmp;
  399.  if NSYMBOLP(var) 
  400.    err("set-fluid!",var,ERR_FIRST | ERR_NSYM);
  401.  tmp = envlookup(var,sym_fluid_environment);
  402.  if NULLP(tmp)
  403.   {err("cannot find simbol in fluid environment",var,ERR_GEN);}
  404.  CDR(tmp)=val;
  405.  return(var);}
  406.  
  407. LISP leval_lambda_fluid(LISP args,LISP env)
  408. {LISP body;
  409.  if NULLP(args) err("fluid-lambda",args,ERR_FIRST | ERR_NPAI);
  410.  body = cdr(args);
  411.  if NULLP(cdr(body))
  412.    body = car(body);
  413.   else body = cons(sym_progn,body);
  414.  return(fluidclosure(env,cons(arglchk(car(args)),body)));}
  415.  
  416. LISP leval_setfluid(LISP args,LISP env)
  417. {return(setfluidvar(car(args),leval(car(cdr(args)),env)));}
  418.  
  419. LISP leval_fluidlet(LISP form,LISP env)
  420. {LISP bin,nenv,res;
  421.  bin = car(form);
  422.  env_test(bin);
  423.  env = envcons(NIL,env);
  424.  nenv = sym_fluid_environment;
  425.  sym_fluid_environment = envcons(NIL,sym_fluid_environment);
  426.  fluid_extend_env(leval_let_env(bin,env));
  427.  form = cons(sym_progn,cdr(form));
  428.  res = leval(form,env);
  429.  sym_fluid_environment = nenv;
  430.  return(res);}
  431.  
  432. LISP fluid_extend_env(LISP bindings)
  433. {LISP list,tmp;
  434.  for(list=bindings; CONSP(list); list = CDR(list))
  435.   {tmp = envlookup(car(CAR(list)),sym_fluid_environment);
  436.    if NNULLP(tmp)
  437.        CDR(tmp)=cdr(CAR(list));
  438.    else
  439.        BINDINGS(sym_fluid_environment)=cons(CAR(list),BINDINGS(sym_fluid_environment));}
  440.  return(sym_fluid_environment);}  
  441.